#lang plai/collector
(define heap-ptr 'uninitialized-heap-ptr)

(define (init-allocator)
  (set! heap-ptr 0))

(define is-collecting false)

;Contract: get-heap-size : nothing -> integer
;Purpose: returns the size of one of the memory spaces used by stop and copy
(define (get-heap-size)
  (floor (/ (heap-size) 2)))


;Contract; outside-heap-bounds : integer -> boolean
;Purpose: Returns whether the given address is inside the current memory space
(define (outside-heap-bounds? n)
  (if (< heap-ptr (get-heap-size))
      (>= (+ heap-ptr n) (- (get-heap-size) 1))
      (>= (+ heap-ptr n) (- (* (get-heap-size) 2) 1))))

(define (gc:alloc-flat v)
  (if (outside-heap-bounds? 1)
      (if (not is-collecting)
          (begin
            (stop-and-copy)
            (gc:alloc-flat v))
          (error 'gc:alloc-flat "out of memory"))
      (begin
        (heap-set! heap-ptr 'prim)
        (heap-set! (+ 1 heap-ptr) v)
        (set! heap-ptr (+ 2 heap-ptr))
        (- heap-ptr 2))))

(define (gc:cons first-addr rest-addr)
  (if (outside-heap-bounds? 2)
      (if (not is-collecting)
          (begin
            (stop-and-copy)
            (gc:cons first-addr rest-addr))
          (error gc:cons "out of memory"))
      (begin
        (heap-set! heap-ptr 'cons)
        (heap-set! (+ 1 heap-ptr) first-addr)
        (heap-set! (+ 2 heap-ptr) rest-addr)
        (set! heap-ptr (+ 3 heap-ptr))
        (- heap-ptr 3))))

(define (gc:cons? addr)
  (eq? (heap-ref addr) 'cons))

(define (gc:first cons-addr)
  (heap-ref (+ 1 cons-addr)))

(define (gc:set-first! cons-addr first-addr)
  (if (gc:cons? cons-addr)
      (heap-set! (+ 1 cons-addr) first-addr)
      (error 'set-first! "expects address of cons")))

(define (gc:rest cons-addr)
  (heap-ref (+ 2 cons-addr)))

(define (gc:set-rest! cons-addr rest-addr)
  (heap-set! (+ 2 cons-addr) rest-addr))

(define (gc:flat? addr)
  (eq? (heap-ref addr) 'prim))

(define (gc:deref addr)
  (heap-ref (+ 1 addr)))

;Contract: stop-and-copy : nothing -> nothing
;Purpose: takes the current data and, using the rootset, copies all
;         objects that are still accesible to the other memory space.
(define (stop-and-copy)
  (begin
    (set! is-collecting true)
    (if (<= heap-ptr (get-heap-size))
        (set! heap-ptr (get-heap-size))
        (set! heap-ptr 0))
    (for/list ([root (get-root-set)])
      (copy-to root (read-root root)))
    (set! is-collecting false)))

;Contract: set-forwarding-pointer : (integer integer) -> nothing
;Purpose: sets the address to a forwarding address for any future
;         objects that may reference this adress   
(define (set-forwarding-pointer old-addr new-addr)
  (heap-set! old-addr new-addr))


;Contract: copy-to : (root? integer) -> integer
;Purpose: accepts a root and the old address of said root, 
;         copies this object to the other memory space,
;         and returns the new address the object resides in
(define (copy-to root old-addr)
  (cond
    [(number? (heap-ref old-addr)) (set-root! root (heap-ref old-addr))]
    [(gc:flat? old-addr)
     (begin
       (define new-addr (gc:alloc-flat (gc:deref old-addr)))
       (if (not (empty? root)) (set-root! root new-addr) empty)
       (set-forwarding-pointer old-addr new-addr)
       new-addr)]
    [(gc:cons? old-addr)
     (begin
       (define new-addr (gc:cons (gc:first old-addr) (gc:rest old-addr)))
       (if (not (empty? root)) (set-root! root new-addr) empty)
       (set-forwarding-pointer old-addr new-addr)
       (gc:set-first! new-addr (copy-to empty (gc:first old-addr)))
       (gc:set-rest! new-addr (copy-to empty (gc:rest old-addr)))
       new-addr)]
    )
  )